home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / XpThemes T271749292001.psc / frmMain.frm (.txt) next >
Encoding:
Visual Basic Form  |  2001-09-30  |  11.5 KB  |  300 lines
  1. VERSION 5.00
  2. Begin VB.Form frmMain 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "Using Themes in VB Applications"
  5.    ClientHeight    =   5415
  6.    ClientLeft      =   45
  7.    ClientTop       =   435
  8.    ClientWidth     =   5685
  9.    LinkTopic       =   "Form1"
  10.    MaxButton       =   0   'False
  11.    MinButton       =   0   'False
  12.    ScaleHeight     =   5415
  13.    ScaleWidth      =   5685
  14.    StartUpPosition =   3  'Windows Default
  15.    Begin VB.Timer tmrProgress 
  16.       Enabled         =   0   'False
  17.       Interval        =   200
  18.       Left            =   120
  19.       Top             =   4920
  20.    End
  21.    Begin VB.PictureBox picPreview 
  22.       Height          =   3135
  23.       Left            =   360
  24.       ScaleHeight     =   205
  25.       ScaleMode       =   3  'Pixel
  26.       ScaleWidth      =   341
  27.       TabIndex        =   1
  28.       Top             =   1800
  29.       Width           =   5175
  30.    End
  31.    Begin VB.CheckBox chkEnableThemes 
  32.       Caption         =   "Enable Themes"
  33.       Height          =   255
  34.       Left            =   2760
  35.       TabIndex        =   0
  36.       Top             =   5040
  37.       Value           =   1  'Checked
  38.       Width           =   2055
  39.    End
  40.    Begin VB.Label Label9 
  41.       AutoSize        =   -1  'True
  42.       BackStyle       =   0  'Transparent
  43.       Caption         =   "Tooltip:"
  44.       Height          =   195
  45.       Left            =   240
  46.       TabIndex        =   12
  47.       Top             =   1200
  48.       Width           =   525
  49.    End
  50.    Begin VB.Label lblTooltip 
  51.       AutoSize        =   -1  'True
  52.       BackStyle       =   0  'Transparent
  53.       Caption         =   "NONE"
  54.       Height          =   195
  55.       Left            =   1560
  56.       TabIndex        =   11
  57.       Top             =   1200
  58.       Width           =   465
  59.    End
  60.    Begin VB.Label Label7 
  61.       AutoSize        =   -1  'True
  62.       BackStyle       =   0  'Transparent
  63.       Caption         =   "Author:"
  64.       Height          =   195
  65.       Left            =   240
  66.       TabIndex        =   10
  67.       Top             =   960
  68.       Width           =   510
  69.    End
  70.    Begin VB.Label lblAuthor 
  71.       AutoSize        =   -1  'True
  72.       BackStyle       =   0  'Transparent
  73.       Caption         =   "NONE"
  74.       Height          =   195
  75.       Left            =   1560
  76.       TabIndex        =   9
  77.       Top             =   960
  78.       Width           =   465
  79.    End
  80.    Begin VB.Label Label5 
  81.       AutoSize        =   -1  'True
  82.       BackStyle       =   0  'Transparent
  83.       Caption         =   "Canonical Name:"
  84.       Height          =   195
  85.       Left            =   240
  86.       TabIndex        =   8
  87.       Top             =   720
  88.       Width           =   1215
  89.    End
  90.    Begin VB.Label lblCanonicalName 
  91.       AutoSize        =   -1  'True
  92.       BackStyle       =   0  'Transparent
  93.       Caption         =   "NONE"
  94.       Height          =   195
  95.       Left            =   1560
  96.       TabIndex        =   7
  97.       Top             =   720
  98.       Width           =   465
  99.    End
  100.    Begin VB.Label lblThemeName 
  101.       AutoSize        =   -1  'True
  102.       BackStyle       =   0  'Transparent
  103.       Caption         =   "NONE"
  104.       Height          =   195
  105.       Left            =   1560
  106.       TabIndex        =   6
  107.       Top             =   480
  108.       Width           =   465
  109.    End
  110.    Begin VB.Label Label3 
  111.       AutoSize        =   -1  'True
  112.       BackStyle       =   0  'Transparent
  113.       Caption         =   "Display Name:"
  114.       Height          =   195
  115.       Left            =   240
  116.       TabIndex        =   5
  117.       Top             =   480
  118.       Width           =   1020
  119.    End
  120.    Begin VB.Label Label2 
  121.       AutoSize        =   -1  'True
  122.       BackStyle       =   0  'Transparent
  123.       Caption         =   "Current Theme:"
  124.       Height          =   195
  125.       Left            =   240
  126.       TabIndex        =   4
  127.       Top             =   240
  128.       Width           =   1095
  129.    End
  130.    Begin VB.Label lblTheme 
  131.       AutoSize        =   -1  'True
  132.       BackStyle       =   0  'Transparent
  133.       Caption         =   "NONE"
  134.       Height          =   195
  135.       Left            =   1560
  136.       TabIndex        =   3
  137.       Top             =   240
  138.       Width           =   465
  139.    End
  140.    Begin VB.Label Label1 
  141.       AutoSize        =   -1  'True
  142.       BackStyle       =   0  'Transparent
  143.       Caption         =   "Preview:"
  144.       Height          =   195
  145.       Left            =   240
  146.       TabIndex        =   2
  147.       Top             =   1560
  148.       Width           =   615
  149.    End
  150. Attribute VB_Name = "frmMain"
  151. Attribute VB_GlobalNameSpace = False
  152. Attribute VB_Creatable = False
  153. Attribute VB_PredeclaredId = True
  154. Attribute VB_Exposed = False
  155. 'ThemeTest created by The KPD-Team
  156. 'Copyright (c) 2001, The KPD-Team
  157. 'Visit our site at http://www.allapi.net/
  158. 'or email us at KPDTeam@allapi.net
  159. Private Const SM_CYCAPTION = 4
  160. Private Const SM_CYBORDER = 6
  161. Private Const SM_CXBORDER = 5
  162. Private Const SM_CXMENUSIZE = 54
  163. Private Const SM_CYMENUSIZE = 55
  164. Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
  165. Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  166. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  167. Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
  168. Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  169. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  170. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  171. Private S As SIZE, FullRect As RECT
  172. Private Sub chkEnableThemes_Click()
  173.     'Enabe or disable theming
  174.     EnableTheming (chkEnableThemes.Value = vbChecked)
  175. End Sub
  176. Private Sub DrawThemedWindow(hdc As Long, DestRect As RECT)
  177.     Dim hTheme As Long, R As RECT, CB As RECT, lTBarHeight As Long
  178.     'Open the WINDOW theme data
  179.     hTheme = OpenThemeData(Me.hWnd, "WINDOW")
  180.     'Draw the Title Bar
  181.     GetThemePartSize hTheme, hdc, WP_CAPTION, CS_ACTIVE, DestRect, TS_TRUE, S
  182.     lTBarHeight = S.cy
  183.     SetRect R, DestRect.Left, DestRect.Top, DestRect.Right, DestRect.Top + S.cy
  184.     DrawThemeBackground hTheme, hdc, WP_CAPTION, CS_ACTIVE, R, ByVal 0&
  185.     'Draw the Close button
  186.     GetThemePartSize hTheme, hdc, WP_CLOSEBUTTON, CBS_NORMAL, DestRect, TS_TRUE, S
  187.     SetRect CB, 0, 0, S.cx, S.cy
  188.     SetRect R, DestRect.Right - CB.Right - 5, DestRect.Top + (lTBarHeight - S.cy) / 2, DestRect.Right - 5, DestRect.Top + CB.bottom + (lTBarHeight - S.cy) / 2
  189.     DrawThemeBackground hTheme, hdc, WP_CLOSEBUTTON, CBS_NORMAL, R, ByVal 0&
  190.     'Draw the Max button
  191.     GetThemePartSize hTheme, hdc, WP_MAXBUTTON, MAXBS_NORMAL, DestRect, TS_TRUE, S
  192.     SetRect CB, 0, 0, S.cx, S.cy
  193.     OffsetRect R, -(CB.Right + 2), 0
  194.     DrawThemeBackground hTheme, hdc, WP_MAXBUTTON, MAXBS_NORMAL, R, ByVal 0&
  195.     'Draw the Min button
  196.     GetThemePartSize hTheme, hdc, WP_MINBUTTON, MINBS_NORMAL, DestRect, TS_TRUE, S
  197.     SetRect CB, 0, 0, S.cx, S.cy
  198.     OffsetRect R, -(CB.Right + 2), 0
  199.     DrawThemeBackground hTheme, hdc, WP_MINBUTTON, MINBS_NORMAL, R, ByVal 0&
  200.     'Draw the left border
  201.     GetThemePartSize hTheme, hdc, WP_FRAMELEFT, FS_ACTIVE, DestRect, TS_TRUE, S
  202.     SetRect R, 0, DestRect.Top + GetSystemMetrics(SM_CYCAPTION), S.cx, DestRect.bottom
  203.     DrawThemeBackground hTheme, hdc, WP_FRAMELEFT, FS_ACTIVE, R, ByVal 0&
  204.     'Draw the right border
  205.     GetThemePartSize hTheme, hdc, WP_FRAMERIGHT, FS_ACTIVE, DestRect, TS_TRUE, S
  206.     SetRect R, DestRect.Right - S.cx, DestRect.Top + GetSystemMetrics(SM_CYCAPTION), DestRect.Right, DestRect.bottom
  207.     DrawThemeBackground hTheme, hdc, WP_FRAMERIGHT, FS_ACTIVE, R, ByVal 0&
  208.     'Draw the bottom border
  209.     GetThemePartSize hTheme, hdc, WP_FRAMEBOTTOM, FS_ACTIVE, DestRect, TS_TRUE, S
  210.     SetRect R, 0, DestRect.bottom - S.cy, DestRect.Right, DestRect.bottom
  211.     DrawThemeBackground hTheme, hdc, WP_FRAMEBOTTOM, FS_ACTIVE, R, ByVal 0&
  212.     'Clean up
  213.     CloseThemeData hTheme
  214. End Sub
  215. Private Sub DrawButton(hdc As Long, DestRect As RECT, Caption As String)
  216.     Dim hTheme As Long
  217.     'Open the BUTTON theme data
  218.     hTheme = OpenThemeData(Me.hWnd, "BUTTON")
  219.     'Draw the button background
  220.     DrawThemeBackground hTheme, hdc, BP_PUSHBUTTON, PBS_NORMAL, DestRect, ByVal 0&
  221.     'Draw the caption
  222.     DrawThemeText hTheme, hdc, BP_PUSHBUTTON, PBS_NORMAL, Caption, -1, DT_CENTER Or DT_VCENTER Or DT_WORD_ELLIPSIS Or DT_SINGLELINE, 0, DestRect
  223.     'Clean up
  224.     CloseThemeData hTheme
  225. End Sub
  226. Private Sub DrawProgressBar(hdc As Long, DestRect As RECT, Value As Long)
  227.     Dim hTheme As Long, R As RECT
  228.     'Open the PROGRESS theme data
  229.     hTheme = OpenThemeData(Me.hWnd, "PROGRESS")
  230.     'Draw the progress bar background
  231.     DrawThemeBackground hTheme, hdc, PP_BAR, 0, DestRect, ByVal 0&
  232.     'Draw the bar
  233.     SetRect R, DestRect.Left + 2, DestRect.Top + 2, DestRect.Left + 2 + (DestRect.Right - DestRect.Left - 4) / 100 * Value - 2, DestRect.bottom - 2
  234.     DrawThemeBackground hTheme, hdc, PP_CHUNK, 0, R, ByVal 0&
  235.     'Clean up
  236.     CloseThemeData hTheme
  237. End Sub
  238. Private Sub Form_Load()
  239.     'Check whether themes are supported
  240.     If AreThemesSupported = False Then
  241.         MsgBox "This project requires Theme support...", vbCritical
  242.         Unload Me
  243.         Exit Sub
  244.     End If
  245.     'Initialize FullRect
  246.     SetRect FullRect, 0, 0, picPreview.ScaleWidth, picPreview.ScaleHeight
  247.     'Retrieve some info about the current theme
  248.     lblTheme.Caption = GetCurrentTheme
  249.     lblThemeName.Caption = GetThemeProperty(lblTheme.Caption, SZ_THDOCPROP_DISPLAYNAME)
  250.     lblCanonicalName.Caption = GetThemeProperty(lblTheme.Caption, SZ_THDOCPROP_CANONICALNAME)
  251.     lblAuthor.Caption = GetThemeProperty(lblTheme.Caption, SZ_THDOCPROP_AUTHOR)
  252.     lblTooltip.Caption = GetThemeProperty(lblTheme.Caption, SZ_THDOCPROP_TOOLTIP)
  253.     'Start the progress bar timer
  254.     tmrProgress.Enabled = True
  255. End Sub
  256. Function GetCurrentTheme() As String
  257.     Dim ZeroPos As Long
  258.     'Create a buffer
  259.     GetCurrentTheme = String(255, 0)
  260.     'Get the name of the current theme
  261.     GetCurrentThemeName GetCurrentTheme, Len(GetCurrentTheme), vbNullString, 0, vbNullString, 0
  262.     'Strip off trailing Chr$(0)'s
  263.     ZeroPos = InStr(1, GetCurrentTheme, Chr$(0))
  264.     If ZeroPos > 0 Then
  265.         GetCurrentTheme = Left$(GetCurrentTheme, ZeroPos - 1)
  266.     End If
  267. End Function
  268. Function GetThemeProperty(sFile As String, sProperty As String) As String
  269.     Dim ZeroPos As Long
  270.     'Create a buffer
  271.     GetThemeProperty = String(255, 0)
  272.     'Retrieve the documentation
  273.     GetThemeDocumentationProperty sFile, sProperty, GetThemeProperty, Len(GetThemeProperty)
  274.     'Strip off trailing Chr$(0)'s
  275.     ZeroPos = InStr(1, GetThemeProperty, Chr$(0))
  276.     If ZeroPos > 0 Then
  277.         GetThemeProperty = Left$(GetThemeProperty, ZeroPos - 1)
  278.     End If
  279. End Function
  280. Private Sub Form_Unload(Cancel As Integer)
  281.     tmrProgress.Enabled = False
  282. End Sub
  283. Private Sub picPreview_Paint()
  284.     Dim R As RECT
  285.     DrawThemedWindow picPreview.hdc, FullRect
  286.     SetRect R, 100, 100, 180, 125
  287.     DrawButton picPreview.hdc, R, "Test"
  288. End Sub
  289. Private Sub tmrProgress_Timer()
  290.     Static Value As Long, Add As Long
  291.     Dim R As RECT
  292.     If Add = 0 Then Add = 1
  293.     Value = Value + 10 * Add
  294.     If Value = 100 Or Value = 0 Then
  295.         Add = -Add
  296.     End If
  297.     SetRect R, 200, 50, 280, 65
  298.     DrawProgressBar picPreview.hdc, R, Value
  299. End Sub
  300.